{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Orca.Prim.InstMon
-- Copyright   :  (c) Stephen Tetley 2013
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Monad to build instrument code - writer-error-state.
--
--------------------------------------------------------------------------------

module Orca.Prim.InstMon
  (
  
    ErrMsg
  , ThrowErr(..)
  , Code

  , execCode
  , newVarId
  , tellPureInit
  , tellStmt

  ) where


import Orca.Prim.Syntax
import Orca.Prim.Utils


import Control.Applicative
import Data.Monoid

-- import Debug.Trace

type ErrMsg = String

class ThrowErr m where
  throwErr :: ErrMsg -> m a



data Skeleton = Skeleton 
    { _pure_inits    :: H LocalDecl
    , _skel_body     :: H Stmt
    }
   


instance Monoid Skeleton where
  mempty                                  = Skeleton emptyH emptyH
  Skeleton i1 b1 `mappend` Skeleton i2 b2 = 
      Skeleton (i1 `appendH` i2) (b1 `appendH` b2)



unskeleton :: Skeleton -> ([LocalDecl], [Stmt])
unskeleton (Skeleton a b) = (toListH a, toListH b)

data St = St { icount :: !Int, kcount :: !Int, acount :: !Int }

newtype Code a = Code { getCode :: St -> Either ErrMsg (a, St, Skeleton) }

instance ThrowErr Code  where
  throwErr msg = Code $ \_ -> Left msg


instance Functor Code  where
  fmap f ma = Code $ \s -> getCode ma s >>= \(a,s1,w) -> return (f a,s1,w)


instance Applicative Code where
  pure a    = Code $ \s -> return (a,s,mempty)
  mf <*> ma = Code $ \s -> getCode mf s  >>= \(f,s1,w1) ->
                           getCode ma s1 >>= \(a,s2,w2) ->
                           return (f a,s2, w1 <> w2)

instance Monad Code where
  return    = pure
  ma >>= k  = Code $ \s -> getCode ma s     >>= \(a,s1,w1) -> 
                           getCode (k a) s1 >>= \(b,s2,w2) ->
                           return (b,s2, w1 <> w2)


state_zero :: St
state_zero = St { icount = 1, kcount = 1, acount = 1 }

execCode :: Code a -> Either ErrMsg ([LocalDecl],[Stmt])
execCode ma = fmap sk $ getCode ma state_zero
  where
    sk (_,_,w)      = unskeleton w


newVarId :: RateId -> Code VarId
newVarId rid = Code $ \s -> return $ case rid of
    A_RATE -> (mkvar (acount s), let a = acount s in s{ acount = a+1 }, mempty)
    K_RATE -> (mkvar (kcount s), let k = kcount s in s{ kcount = k+1 }, mempty)
    I_RATE -> (mkvar (icount s), let i = icount s in s{ icount = i+1 }, mempty)
  where
    mkvar i = Local rid i


tellPureInit :: LocalDecl -> Code ()
tellPureInit decl1 = Code $ \s -> return ((),s, w1 )
  where
    w1 = Skeleton (wrapH decl1) emptyH


tellStmt :: Stmt -> Code ()
tellStmt stmt1 = Code $ \s -> return ((),s, w1 )
  where
    w1 = Skeleton emptyH (wrapH stmt1)




